home *** CD-ROM | disk | FTP | other *** search
- /* Wilcoxen Sign Rank Test */
-
- options results
- if ~show('P','TCALC') then do
- address command 'run turbocalc:turbocalc'
- address command 'waitforport TCALC'
- loadflag=1
- end
- address 'TCALC'
- 'DEFPUBSCREEN()'
- /* Add-in Rexx Math Library needed for some routines */
- signal on syntax
- if ~show('l','rexxmathlib.library') then
- call addlib('rexxmathlib.library',0,-30)
- if ~show('l','rexxreqtools.library') then
- call addlib('rexxreqtools.library',0,-30)
- if ~show('l','rexxsupport.library') then
- call addlib('rexxsupport.library',0,-30)
- /* add to library list */
- signal off syntax
-
- /* Start Main Routine */
- if loadflag=1 then 'Load()'
- 'ActivateWindow()'
- range=rtgetstring(,"Enter Cell Range for Input","Input Request") /*,,'rt_pubscrname="TCALC"')*/
- colon=pos(":",range)
- if colon=0 then do
- 'Message "Please select a range before executing this script"'
- 'DEFPUBSCREEN("Workbench")'
- exit
- end
-
- /* Find cell references and cell, column numbers */
- start_cell=substr(range,1,colon-1)
- end_cell=substr(range,colon+1)
- start_row=cellrow(start_cell)
- end_row=cellrow(end_cell)
- start_col=cellcol(start_cell)
- end_col=cellcol(end_cell)
- NRows=end_row-start_row+1
- NCols=end_col-start_col+1
- if NCols>2 then do
- 'Message "Only Two Columns Allowed!"'
- 'DEFPUBSCREEN("Workbench")'
- exit
- end
-
- /* Get cell reference for output range */
- out_cell=rtgetstring(,"Enter Cell Reference for Output","Input Request") /*,,'rt_pubscrname="TCALC"')*/
- if out_cell="" then do
- 'DEFPUBSCREEN("Workbench")'
- exit
- end
- if length(out_cell)<2 | datatype(left(out_cell,1),'n') then do
- 'Message "Invalid cell reference"'
- 'DEFPUBSCREEN("Workbench")'
- exit
- end
- /* Suppress Screen Redraw to Speed Things Up */
- 'Refresh 0'
-
- /* Open a small output window on tcalc screen*/
- fo=0
- CR='0a'x
- DisplayMsg="Calculating...Please Wait."||CR||"User input is disabled during calculation."||CR
- if open(6Info, 'con:100/0/450/80/Progress/SCREEN TCALC', w) then do
- call writeln(6Info, DisplayMsg)
- fo=1
- end
- else do
- 'Message "TCALC Screen not available for Progress messages"'
- end
- CALL DELAY(150)
-
- /* Get cell references for top cell in each column */
- 'SelectCell' start_cell
- do col=start_col to end_col
- 'GetCursorPos'
- top_cell.col=result
- 'Column 1'
- end
-
- /* Get labels for later use on output */
- 'SelectCell' start_cell
- 'GetValue'
- testlabel=result
- testlabel=strip(testlabel)
- if datatype(testlabel,'n')=1 then do
- labelflag=0
- do x=1 to NCols
- title.x="Column "||x
- end
- end
- else do
- labelflag=1
- NRows=NRows-1
- do x=1 to NCols
- 'GetValue'
- str=result
- title.x=translate(strip(str),"_"," ")
- 'Column 1'
- end
- end
- if fo then call writech(6Info,"Progress...10 ")
-
- /* Get data from cell range */
- col=start_col
- do x=1 to NCols
- 'SelectCell' top_cell.col
- if labelflag=1 then 'CursorDown 1'
- do y=1 to NRows
- 'GetValue'
- valtest=result
- if datatype(valtest)='NUM' then do
- 'GetValue'
- val=result
- data.x.y=val
- end
- 'CursorDown 1'
- end
- col=col+1
- val=0
- end
- if fo then call writech(6Info,"20 ")
- /* Calculate Differences */
- d.=0
- s.=""
- count=0
- zero=0
- Do y=1 to NRows
- d.y=(data.1.y)-(data.2.y)
- diff.y=d.y
- if (d.y)~=0 then count=count+1
- if (d.y)=0 then do
- zero=zero+1
- s.y=""
- end
- if (d.y)>0 then s.y="pos"
- if (d.y)<0 then do
- s.y="neg"
- d.y=abs(d.y)
- end
- end
- if fo then call writech(6Info,"30 ")
- /*Sort Values */
- call Sort()
- if fo then call writech(6Info,"40 ")
- /*Calculate Ranks */
-
- rank.=0
- N=count
- Do y=1+zero to NRows
- z=y+1
- if (d.y)=(d.z) then do
- cnt=1
- beginrank=y
- avrank=y
- endrank=0
- do until endrank~=0
- y=y+1
- avrank=avrank+y
- z=y+1
- cnt=cnt+1
- if (d.y)~=(d.z) then endrank=y
- end
- avrank=avrank/cnt
- do y=beginrank to endrank
- rank.y=trunc(avrank,2)-zero
- end
- y=y-1
- end
- else rank.y=y-zero
-
- end
- if fo then call writech(6Info,"60 ")
- /* Calculate Rank Sign Sums */
- sumpos=0
- sumneg=0
- Do y=1+zero to NRows
- If s.y="neg" then sumneg=sumneg+(rank.y)
- If s.y="pos" then sumpos=sumpos+(rank.y)
- end
- T=0
- If abs(sumneg)<sumpos then
- T=abs(sumneg)
- else
- T=sumpos
- if fo then call writech(6Info,"90 ")
- /* Calculate z */
- N=count
- aa=T-(N*(N+1)/4)
- sdev=sqrt((N*(N+1)*(2*N+1))/24)
- zz=aa/sdev
- if fo then call writech(6Info,"90 ")
- /* Calculate Probability */
-
- select
- when zz<(-6.5) then P=0
- when zz>6.5 then P=1
- otherwise
- P=abs(calcp(zz))
- end
- if fo then do
- call writeln(6Info,"100")
- call writeln(6Info,"Writing output to window...")
- end
- /* Output */
- dank=0
- 'SelectCell' out_cell
- 'Put "Wilcoxon Matched-Pairs Signed Ranks Test"'
- 'CursorDown 2'
- 'GetCursorPos'
- top_cell=result
- 'Alignment 2'
- 'Put "(X-Y)"'
- 'CursorDown 1'
- Do y=1 to NRows
- 'Put' diff.y
- 'CursorDown 1'
- end
- 'CursorDown 1'
- 'Put "Sum of Neg. Ranks"'
- 'CursorDown 1'
- 'Put "Sum of Pos. Ranks"'
- 'CursorDown 1'
- 'Put "Wilcoxon T:"'
- 'CursorDown 1'
- 'Put "Ranked Obs. (N):"'
- 'CursorDown 1'
- 'Put "z:"'
- 'CursorDown 1'
- 'Put "Prob. (Z<=z):"'
- 'SelectCell' top_cell
- 'Column 1'
- 'ColumnWidth 18'
- 'Put "Sorted ABS Values"'
- 'CursorDown 1'
- Do y=1 to NRows
- 'Put' d.y
- 'CursorDown 1'
- end
- 'SelectCell' top_cell
- 'Column 2'
- 'Alignment 2'
- 'Put "Rank"'
- 'CursorDown 1'
- Do y=1 to NRows
- if (s.y)="neg" then rank.y=-(rank.y)
- if (s.y)="" then do
- 'Alignment 2'
- 'Put "--"'
- 'CursorDown 1'
- end
- else do
- 'Put' rank.y
- 'CursorDown 1'
- end
- end
- 'CursorDown 1'
- 'Put' sumneg
- 'CursorDown 1'
- 'Put' sumpos
- 'CursorDown 1'
- 'Put' T
- 'CursorDown 1'
- 'Put' count
- 'CursorDown 1'
- 'Put' format(zz,,4)
- 'CursorDown 1'
- 'Put' format(P,,6)
- 'Refresh 1'
- 'Refresh 2'
- /*'Message' "Finished"*/
- /*indicate the main script is finished*/
- DisplayMsg="Cleaning up ...."||CR||"Exiting"
- result=writeln(6Info, DisplayMsg)
- if result~=0 then do
- /*Wait 3 seconds*/
- CALL DELAY(150)
- /* close window*/
- result=close(6Info)
- end
- 'DEFPUBSCREEN("Workbench")'
- exit
-
- /* Procedures */
-
- cellrow: procedure
- do
- parse arg cell
- do charpos=2 to length(cell)
- if datatype(substr(cell,charpos,1),n) then return substr(cell,charpos)
- end
- return 0
- end
- Return
-
- cellcol: procedure
- do
- parse arg cell
- labels="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- cell=upper(cell)
- len=length(cell)
- val=0
- do charpos=1 to len
- if datatype(substr(cell,charpos,1),n) then
- do cell=reverse(substr(cell,1,charpos-1))
- do x=1 to length(cell)
- val=(26**(x-1))*pos(substr(cell,x,1),labels)+val
- end
- return val
- end
- end
- return 0
- end
- Return
- /* It is important to put the exposed array at the end of the next line */
- Sort: procedure expose NRows d. s.
-
- L=(xtoy(2,int(log(NRows)/log(2))))-1
- Do Until L<1
- L=trunc(int(L/2))
- Do J=1 to L
- Do K=J+L To NRows By L
- I=K
- dumdat=d.I
- dumdats=s.I
- Do while I>L
- y=I-L
- If d.y ~> dumdat then Leave
- d.I=d.y
- s.I=s.y
- I=I-L
- End
- d.I=dumdat
- s.I=dumdats
- End
- End
- End
- Return
-
- syntax:
- if arg(1)='FAIL' then do
- 'Message "Library is unavailable."'
- 'DEFPUBSCREEN("Workbench")'
- exit
- end
- 'DEFPUBSCREEN("Workbench")'
- exit
-
- calcp:
- arg g
- factk=1
- pp=0
- itts=0
- term=1
- k=0
- do while abs(term)>(exp(-23))
- term=.3989422804*((-1)**k)*(g**k)/(2*k+1)/(2**k)*(g**(k+1))/factk
- pp=pp+term
- k=k+1
- factk=factk*k
- end
- pp=pp+.5
- if (pp<.0000000001) then pp=0
- return pp
-
- Format: procedure
-
- arg number, before, after
- CallLine = SIGL
- if ~datatype(CallLine, 'N') then CallLine = '??'
-
- /* Make sure we have a number as first (required) argument */
- if ~datatype(number, 'N') then do
- if number = '' then
- fc = 17 /* Wrong number of arguments */
- else
- fc = 47 /* Arithmetic conversion error */
- signal FormatSyntaxError
- end
- num = number + 0
- if before = '' & after = '' then
- return num
- else do
- parse var num integer '.' fraction
- if before = '' then before = length(integer)
- if after = '' then after = length(fraction)
- if ~datatype(before, N) | ~datatype(after, N) then
- do fc = 18
- signal FormatSyntaxError
- end
- if before < length(integer) then do
- fc = 18
- signal FormatSyntaxError
- end
- if after ~= length(fraction) then do
- fraction = trunc(('.'fraction'0') + ('.'copies('0', after)'5'), after)
- if integer<1&integer>-1 then integer=integer
- else integer = integer + (fraction % 1)
- fraction = substr(fraction, 3)
- end
- if fraction >= 0 then
- return right(integer, before)'.'fraction
- else
- return right(integer, before)
- end
-
- FormatSyntaxError:
- if show('F', STDERR) then
- call writeln(STDERR, '+++ Error' fc 'in line' CallLine':' errortext(fc))
- else
- mess='+++ Error' fc 'in line' CallLine':' errortext(fc)
- 'Message' mess
- parse source Func .
- if Func = 'FUNCTION' then do
- 'DEFPUBSCREEN("Workbench")'
- exit "Err"
- end
- else do
- 'DEFPUBSCREEN("Workbench")'
- exit 10
- end